home *** CD-ROM | disk | FTP | other *** search
/ PC Plus SuperCD (UK) 1997 February / PC Plus Super CD (Issue 124) (PCP124-2-97) (February 1997).iso / ms / vb5cce / controls / samples / axbutton / axbutton.exe / AXButton.ctl < prev    next >
Encoding:
Text File  |  1996-10-22  |  19.6 KB  |  401 lines
  1. VERSION 5.00
  2. Begin VB.UserControl AXButtonCtl 
  3.    CanGetFocus     =   0   'False
  4.    ClientHeight    =   2610
  5.    ClientLeft      =   0
  6.    ClientTop       =   0
  7.    ClientWidth     =   3135
  8.    ClipControls    =   0   'False
  9.    ForwardFocus    =   -1  'True
  10.    LockControls    =   -1  'True
  11.    PropertyPages   =   "AXButton.ctx":0000
  12.    ScaleHeight     =   2610
  13.    ScaleWidth      =   3135
  14.    Begin VB.Line lnRight 
  15.       BorderColor     =   &H00808080&
  16.       BorderWidth     =   2
  17.       Visible         =   0   'False
  18.       X1              =   3030
  19.       X2              =   3030
  20.       Y1              =   60
  21.       Y2              =   2520
  22.    End
  23.    Begin VB.Line lnBottom 
  24.       BorderColor     =   &H00808080&
  25.       BorderWidth     =   2
  26.       Visible         =   0   'False
  27.       X1              =   60
  28.       X2              =   3030
  29.       Y1              =   2520
  30.       Y2              =   2520
  31.    End
  32.    Begin VB.Line lnTop 
  33.       BorderColor     =   &H80000014&
  34.       BorderWidth     =   2
  35.       Visible         =   0   'False
  36.       X1              =   60
  37.       X2              =   2970
  38.       Y1              =   60
  39.       Y2              =   60
  40.    End
  41.    Begin VB.Line lnLeft 
  42.       BorderColor     =   &H80000014&
  43.       BorderWidth     =   2
  44.       Visible         =   0   'False
  45.       X1              =   60
  46.       X2              =   60
  47.       Y1              =   60
  48.       Y2              =   2490
  49.    End
  50. End
  51. Attribute VB_Name = "AXButtonCtl"
  52. Attribute VB_GlobalNameSpace = False
  53. Attribute VB_Creatable = True
  54. Attribute VB_PredeclaredId = False
  55. Attribute VB_Exposed = True
  56. Option Explicit
  57. '------------------------------------------------------------------
  58. ' API Declares...
  59. '------------------------------------------------------------------
  60. Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
  61. Private Declare Function SetCapture Lib "user32" (ByVal hWnd As Long) As Long
  62. Private Declare Function ReleaseCapture Lib "user32" () As Long
  63.  
  64. '------------------------------------------------------------------
  65. ' Private Variables...
  66. '------------------------------------------------------------------
  67. Dim MouseDown As Boolean                        ' Flag - set when left button is pressed down
  68. Dim MouseOver As Boolean                        ' Flag - set when mouse pointer is over button
  69. Dim MouseCaptured As Boolean                    ' Flag - set when mouse pointer is captured by button control
  70. Dim ClearURLOnly As Boolean                     '
  71. Dim ClearPictureOnly As Boolean                 '
  72.  
  73. Dim StaticWidth As Long
  74. Dim StaticHeight As Long
  75. Dim gPicture As StdPicture                      ' Global picture property variable
  76. Dim gURLPicture As String                       ' Global URL picture property string variable
  77. Const pPICTURE = "Picture"                      ' Picture property name constant
  78. Const pURLPICTURE = "URLPicture"                ' URLPicture property name constant
  79. Const Bdr = 10
  80. Const SND_ASYNC = &H1
  81. Const EVENT_MenuCommand = "MenuCommand"         ' Sound event name for button mousedown event
  82. Const EVENT_MenuPopup = "MenuPopup"             ' Sound event name for button enterover event
  83.  
  84. '------------------------------------------------------------------
  85. ' Private Enum...
  86. '------------------------------------------------------------------
  87. Enum ButtonState
  88.     Up = 0                                      ' Draw button raised up border
  89.     Down = 1                                    ' Draw button sunken down border
  90.     Flat = 2                                    ' Draw button flat - no border
  91. End Enum
  92.  
  93. '------------------------------------------------------------------
  94. ' Container Event Declarations:
  95. '------------------------------------------------------------------
  96. Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  97. Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  98. Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  99. Event Click()
  100.  
  101. '------------------------------------------------------------------
  102. Private Sub UserControl_Click()
  103. '------------------------------------------------------------------
  104.     RaiseEvent Click                            ' Dispatch click event to container.
  105. '------------------------------------------------------------------
  106. End Sub
  107. '------------------------------------------------------------------
  108.  
  109. '------------------------------------------------------------------
  110. Private Sub UserControl_Initialize()
  111. '------------------------------------------------------------------
  112.     StaticWidth = UserControl.Width             ' Get default button size
  113.     StaticHeight = UserControl.Height
  114. '------------------------------------------------------------------
  115. End Sub
  116. '------------------------------------------------------------------
  117.  
  118. '------------------------------------------------------------------
  119. Private Sub UserControl_AsyncReadComplete(AsyncProp As AsyncProperty)
  120. '------------------------------------------------------------------
  121.     If (AsyncProp.PropertyName = pPICTURE) Then ' Picture download is complete
  122.         ClearPictureOnly = True
  123.         Set Picture = AsyncProp.Value           ' Store picture data to property...
  124.         ClearPictureOnly = False
  125.     End If
  126. '------------------------------------------------------------------
  127. End Sub
  128. '------------------------------------------------------------------
  129.  
  130. '------------------------------------------------------------------
  131. Private Sub UserControl_InitProperties()
  132. '------------------------------------------------------------------
  133.     SetButtonState Up                                   ' Draw button flat
  134. '------------------------------------------------------------------
  135. End Sub
  136. '------------------------------------------------------------------
  137.  
  138. '------------------------------------------------------------------
  139. Private Sub UserControl_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  140. '------------------------------------------------------------------
  141.     If ((Button And vbLeftButton) = vbLeftButton) Then  ' Only do if left mouse button was pressed
  142.         MouseDown = True                                ' Set MouseDown state flag
  143.         SetButtonState Down                             ' Draw button down
  144.         PlaySound EVENT_MenuCommand, 0, SND_ASYNC       ' Play event sound for mousedown...
  145.     End If
  146.     RaiseEvent MouseDown(Button, Shift, X, Y)           ' Dispatch mousedown event to container.
  147. '------------------------------------------------------------------
  148. End Sub
  149. '------------------------------------------------------------------
  150.  
  151. '------------------------------------------------------------------
  152. Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  153. '------------------------------------------------------------------
  154.     If ((Button And vbLeftButton) = vbLeftButton) Then  ' Only do if left mouse button was pressed
  155.         MouseDown = False                               ' Clear MouseDown flag
  156.         SetButtonState Up                               ' Draw button up
  157.     End If
  158.     
  159.     MouseCaptured = True                                ' Reset MouseCaptured flag
  160.     SetCapture UserControl.hWnd                         ' ReCapture Mouse, Click seems to disable previous captures...
  161.     RaiseEvent MouseUp(Button, Shift, X, Y)             ' Dispatch mouseup event to container.
  162. '------------------------------------------------------------------
  163. End Sub
  164. '------------------------------------------------------------------
  165.  
  166. '------------------------------------------------------------------
  167. Private Sub UserControl_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  168. '------------------------------------------------------------------
  169.     With UserControl
  170.         ' Determine if mouse is currently moving over button.
  171.         MouseOver = (0 <= X) And (X <= .Width) And (0 <= Y) And (Y <= .Height)
  172.         
  173.         ' Determine if left mouse button is down
  174.         MouseDown = ((Button And vbLeftButton) = vbLeftButton)
  175.         
  176.         If MouseOver Then
  177.             If MouseDown Then
  178.                 SetButtonState Down                         ' Draw button down...
  179.             Else
  180.                 SetButtonState Up                           ' Draw button up
  181.             End If
  182.             If Not MouseCaptured Then                       ' Mouse captured
  183.                 PlaySound EVENT_MenuPopup, 0, SND_ASYNC     ' Play mouse move enter event sound
  184.                 SetCapture .hWnd                            ' Capture all mouse movements and send to UserControl
  185.                 MouseCaptured = True                        ' Set MouseCaptured flag
  186.             End If
  187.         Else
  188.             If MouseDown Then
  189.                 SetButtonState Up                           ' Draw button up
  190.             Else
  191.                 SetButtonState Flat                         ' Draw button flat
  192.                 If MouseCaptured Then
  193.                     ReleaseCapture                          ' Release outside capture of mouse button
  194.                     MouseCaptured = False                   ' Turn capture flag off...
  195.                 End If
  196.             End If
  197.         End If
  198.     End With
  199.     RaiseEvent MouseMove(Button, Shift, X, Y)               ' Dispatch mousemove event to container
  200. '------------------------------------------------------------------
  201. End Sub
  202. '------------------------------------------------------------------
  203.  
  204. '------------------------------------------------------------------
  205. Private Sub SetButtonState(State As ButtonState)
  206. '------------------------------------------------------------------
  207.     Select Case State                               ' Determine draw state
  208.     Case Up                                         ' Draw button up
  209.         lnTop.BorderColor = vb3DHighlight           ' Set appropriate color for lines...
  210.         lnLeft.BorderColor = vb3DHighlight
  211.         lnBottom.BorderColor = vb3DShadow
  212.         lnRight.BorderColor = vb3DShadow
  213.     Case Down                                       ' Draw button down
  214.         lnTop.BorderColor = vb3DShadow              ' Set appropriate color for lines...
  215.         lnLeft.BorderColor = vb3DShadow
  216.         lnBottom.BorderColor = vb3DHighlight
  217.         lnRight.BorderColor = vb3DHighlight
  218.     End Select
  219.     
  220.     lnBottom.Visible = (State <> Flat)              ' Show or Hide lines based on state of button
  221.     lnTop.Visible = (State <> Flat)
  222.     lnLeft.Visible = (State <> Flat)
  223.     lnRight.Visible = (State <> Flat)
  224. '------------------------------------------------------------------
  225. End Sub
  226. '------------------------------------------------------------------
  227.  
  228. '------------------------------------------------------------------
  229. Public Property Let URLPicture(Url As String)
  230. Attribute URLPicture.VB_ProcData.VB_Invoke_PropertyPut = ";Misc"
  231. '------------------------------------------------------------------
  232.     If (gURLPicture <> Url) Then                    ' Do only if value has changed...
  233.         ClearPictureOnly = Not ClearURLOnly         ' If Picture property is not being set by the URLPicture _
  234.                                                       property then clear the URLPicture value...
  235.         gURLPicture = Url                           ' Save url string value to global variable
  236.         PropertyChanged pURLPICTURE                 ' Notify property bag of property change
  237.             
  238.         If Not ClearURLOnly Then
  239.             On Error GoTo ErrorHandler              ' Handle Error if URL is unavailable or Invalid...
  240.             UserControl.AsyncRead Url, vbAsyncTypePicture, pPICTURE ' Begin async download of bitmap
  241.         End If
  242.     End If
  243. '------------------------------------------------------------------
  244. ErrorHandler:
  245. '------------------------------------------------------------------
  246.     ClearPictureOnly = False
  247. '------------------------------------------------------------------
  248. End Property
  249. '------------------------------------------------------------------
  250.  
  251. '------------------------------------------------------------------
  252. Public Property Get URLPicture() As String
  253. '------------------------------------------------------------------
  254.     URLPicture = gURLPicture                        ' Return URL string value
  255. '------------------------------------------------------------------
  256. End Property
  257. '------------------------------------------------------------------
  258.  
  259. '------------------------------------------------------------------
  260. Public Property Set Picture(ByVal Image As Picture)
  261. '------------------------------------------------------------------
  262.     If Not ClearPictureOnly Then
  263.         ClearURLOnly = True                         ' If Picture property is not being set by the URLPicture
  264.         URLPicture = ""                             ' property then clear the URLPicture value...
  265.         ClearURLOnly = False                        ' If Picture property is not being set by the URLPicture
  266.     End If
  267.     
  268.     If (Not Image Is Nothing) Then
  269.         If (Image.Handle = 0) Then Set Image = Nothing
  270.     End If
  271.     Set gPicture = Image                            ' Store image to global variable
  272.     
  273.     With UserControl
  274.         If Not Image Is Nothing Then                ' Check for Null picture value
  275.             StaticWidth = .ScaleX(gPicture.Width, vbHimetric, vbTwips)   ' Save size of bitmap
  276.             StaticHeight = .ScaleY(gPicture.Height, vbHimetric, vbTwips)
  277.         End If
  278.         .Cls                                        ' Clear previous picture image...
  279.     End With
  280.     
  281.     UserControl_Resize                              ' Resize button to fit image
  282.     UserControl_Paint                               ' Refresh image on button...
  283.     PropertyChanged pPICTURE                        ' Notify property bag of property change
  284. '------------------------------------------------------------------
  285. End Property
  286. '------------------------------------------------------------------
  287.  
  288. '------------------------------------------------------------------
  289. Public Property Get Picture() As Picture
  290. Attribute Picture.VB_ProcData.VB_Invoke_Property = "StandardPicture"
  291. '------------------------------------------------------------------
  292.     Set Picture = gPicture                          ' Return value of picture property
  293. '------------------------------------------------------------------
  294. End Property
  295. '------------------------------------------------------------------
  296.  
  297. '------------------------------------------------------------------
  298. Private Sub UserControl_Paint()
  299. '------------------------------------------------------------------
  300.     If (gPicture Is Nothing) Then Exit Sub          ' Don't draw if picture is invalid...
  301.     
  302.     ' Draw picture from property to usercontrol...
  303.     With UserControl
  304.         .PaintPicture gPicture, _
  305.                      .ScaleX(lnLeft.BorderWidth, vbTwips, vbHimetric), _
  306.                      .ScaleY(lnTop.BorderWidth, vbTwips, vbHimetric), _
  307.                      .ScaleX(.Width - (2 * lnLeft.BorderWidth), vbTwips, vbHimetric), _
  308.                      .ScaleY(.Height - (2 * lnTop.BorderWidth), vbTwips, vbHimetric), _
  309.                       0, _
  310.                       0, _
  311.                       gPicture.Width, _
  312.                       gPicture.Height
  313.     End With
  314. '------------------------------------------------------------------
  315. End Sub
  316. '------------------------------------------------------------------
  317.  
  318. '------------------------------------------------------------------
  319. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  320. '------------------------------------------------------------------
  321.     Dim Pic As StdPicture
  322.     Dim Url As String
  323. '------------------------------------------------------------------
  324.     On Error GoTo ErrorHandler                      ' Handler weird host problems
  325.     
  326.     If UserControl.Ambient.UserMode Then            ' Are we hosted in an IDE ???
  327.         SetButtonState Flat                         ' Draw button flat
  328.     Else
  329.         SetButtonState Up                           ' Draw button flat
  330.     End If
  331.     
  332.     ' Read in the properties that have been saved into the PropertyBag...
  333.     With PropBag
  334.         Url = .ReadProperty(pURLPICTURE, "")         ' Read URLPicture property value
  335.         If (Url <> "") Then                         ' If a URL has been entered...
  336.             URLPicture = Url                        ' Attempt to download it now, URL may be unabailable at this time
  337.         Else
  338.             Set Pic = .ReadProperty(pPICTURE, Nothing) ' Read Picture property value
  339.             If Not (Pic Is Nothing) Then            ' URL is not available
  340.                 Set Picture = Pic                   ' Use existing picture (This is used only if URL is empty)
  341.             End If
  342.         End If
  343.     End With
  344. '------------------------------------------------------------------
  345. ErrorHandler:
  346. '------------------------------------------------------------------
  347. ' Just quit nicely...
  348. '------------------------------------------------------------------
  349. End Sub
  350. '------------------------------------------------------------------
  351.  
  352. '------------------------------------------------------------------
  353. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  354. '------------------------------------------------------------------
  355.     On Error GoTo ErrorHandler                      ' Handler weird host problems
  356.     With PropBag
  357.         .WriteProperty pURLPICTURE, gURLPicture     ' Write URLPicture property to propertybag
  358.         .WriteProperty pPICTURE, gPicture           ' Write Picture property to propertybag
  359.     End With
  360. '------------------------------------------------------------------
  361. ErrorHandler:
  362. '------------------------------------------------------------------
  363. ' Just quit nicely...
  364. '------------------------------------------------------------------
  365. End Sub
  366. '------------------------------------------------------------------
  367.  
  368. '------------------------------------------------------------------
  369. Private Sub UserControl_Resize()
  370. '------------------------------------------------------------------
  371.     Dim W As Long, H As Long, L As Long, T As Long
  372. '------------------------------------------------------------------
  373.     L = 1                                           ' Set default left position
  374.     T = 1                                           ' Set default top positon
  375.     With UserControl
  376.         If gPicture Is Nothing Then                 ' If picture is invalid valid
  377.             StaticWidth = .Width                    ' Update static width size
  378.             StaticHeight = .Height                  ' Update static height size
  379.         Else                                        ' Picture is valid...
  380.             .Width = StaticWidth                    ' Fix control size to picture width
  381.             .Height = StaticHeight                  ' ...
  382.         End If
  383.         W = .ScaleWidth - Bdr                       ' Calculate w position for lines
  384.         H = .ScaleHeight - Bdr                      ' Calculate h position for lines
  385.     End With
  386.     With lnLeft
  387.         .X1 = L:    .X2 = L:    .Y1 = T:    .Y2 = H  ' Move lines to new positions
  388.     End With
  389.     With lnRight
  390.         .X1 = W:    .X2 = W:    .Y1 = T:    .Y2 = H
  391.     End With
  392.     With lnTop
  393.         .X1 = L:    .X2 = W:    .Y1 = T:    .Y2 = T
  394.     End With
  395.     With lnBottom
  396.         .X1 = L:    .X2 = W:    .Y1 = H:    .Y2 = H
  397.     End With
  398. '------------------------------------------------------------------
  399. End Sub
  400. '------------------------------------------------------------------
  401.